home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / pcmagazi / 1992 / 16 / soundex.bas < prev    next >
BASIC Source File  |  1992-01-26  |  1KB  |  43 lines
  1. DEFINT A-Z
  2. DECLARE FUNCTION Soundex$ (Word$)
  3.  
  4. CLS
  5. LOCATE 2, 32, 1
  6. PRINT ">>> SOUNDEX <<<"
  7. PRINT : PRINT
  8.  
  9. DO
  10.   LINE INPUT "Enter Last Name: "; LastName$
  11.   PRINT "Soundex Code: "; Soundex$(LastName$)
  12.   PRINT "Code Another Name (Y/N): ";
  13.   YN$ = UCASE$(INPUT$(1))
  14.   IF YN$ <> "Y" THEN END
  15.   PRINT : PRINT
  16. LOOP
  17.  
  18. FUNCTION Soundex$ (Text$)
  19.  
  20.   Word$ = UCASE$(Text$)                     'work with a capitalized copy
  21.   Number$ = "01230120022455012623010202"    'table of SOUNDEX code values
  22.  
  23.   SdxString$ = LEFT$(Word$, 1)              'start with the first letter
  24.  
  25.   FOR I = 2 TO LEN(Word$)                   'then consider what remains
  26.     E$ = MID$(Word$, I, 1)                  'isolate this character
  27.     E = ASC(E$) - 64                        'convert ASCII to table index
  28.     IF E >= 1 AND E <= 26 THEN              'accept only if it's a letter
  29.       This$ = MID$(Number$, E, 1)           'look this up in the table
  30.       IF This$ <> Prev$ AND This$ <> "0" THEN 'if different and not a vowel
  31.         Prev$ = This$                         'save the previous code
  32.         SdxString$ = SdxString$ + This$       'build the output string
  33.         Prev$ = This$
  34.       END IF
  35.     END IF
  36.   NEXT I
  37.  
  38.   'Pad the output with trailing zeros and then clip it to four characters.
  39.   Soundex$ = LEFT$(SdxString$ + "0000", 4)
  40.  
  41. END FUNCTION
  42.  
  43.